home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / tooltalk / tooltalk-init.el < prev    next >
Encoding:
Text File  |  1995-06-30  |  6.7 KB  |  216 lines
  1. ;;; -*- Mode: Emacs-Lisp -*-
  2. ;;;
  3. ;;; Registration of the default Tooltalk patterns and handlers.
  4. ;;;
  5. ;;; @(#)tooltalk-init.el 1.8 94/02/22
  6.  
  7.  
  8. (defvar tooltalk-eval-pattern
  9.   '(category TT_HANDLE
  10.        scope TT_SESSION
  11.           op "emacs-eval"
  12.     callback tooltalk-eval-handler))
  13.  
  14. (defvar tooltalk-load-file-pattern
  15.   '(category TT_HANDLE
  16.        scope TT_SESSION
  17.           op "emacs-load-file"
  18.     args ((TT_IN "file" "string"))
  19.     callback tooltalk-load-file-handler))
  20.  
  21. (defvar tooltalk-make-client-frame-pattern 
  22.   '(category TT_HANDLE
  23.        scope TT_SESSION
  24.           op "emacs-make-client-screen"
  25.     callback tooltalk-make-client-frame-handler))
  26.  
  27. (defvar tooltalk-status-pattern 
  28.   '(category TT_HANDLE
  29.        scope TT_SESSION
  30.           op "emacs-status"
  31.     callback tooltalk-status-handler))
  32.  
  33.  
  34. (defvar initial-tooltalk-patterns ())
  35.  
  36. (defun dispatch-initial-tooltalk-message (m)
  37.   (let ((opsym (intern (get-tooltalk-message-attribute m 'op)))
  38.     (patterns initial-tooltalk-patterns))
  39.     (while patterns
  40.       (let ((p (car patterns)))
  41.     (if (eq opsym (tooltalk-pattern-prop-get p 'opsym))
  42.         (let ((callback (tooltalk-pattern-prop-get p 'callback)))
  43.           (if callback (funcall callback m p))
  44.           (setq patterns '()))
  45.       (setq patterns (cdr patterns)))))))
  46.  
  47. (defun make-initial-tooltalk-pattern (args)
  48.   (let ((opcdr (cdr (memq 'op args)))
  49.     (cbcdr (cdr (memq 'callback args))))
  50.     (if (and (consp opcdr) (consp cbcdr))
  51.     (let ((plist (list 'opsym (intern (car opcdr)) 'callback (car cbcdr))))
  52.       (make-tooltalk-pattern (append args (list 'plist plist))))
  53.       (make-tooltalk-pattern args))))
  54.  
  55. (defun register-initial-tooltalk-patterns ()
  56.   (mapcar #'register-tooltalk-pattern 
  57.       (setq initial-tooltalk-patterns
  58.         (mapcar #'make-initial-tooltalk-pattern
  59.             (list tooltalk-eval-pattern
  60.                   tooltalk-load-file-pattern
  61.                   tooltalk-make-client-frame-pattern
  62.                   tooltalk-status-pattern))))
  63.   (add-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
  64.  
  65.  
  66. (defun unregister-initial-tooltalk-patterns ()
  67.   (mapcar 'destroy-tooltalk-pattern initial-tooltalk-patterns)
  68.   (setq initial-tooltalk-patterns ())
  69.   (remove-hook 'tooltalk-unprocessed-message-hook 'dispatch-initial-tooltalk-message))
  70.  
  71.  
  72. (defun tooltalk:prin1-to-string (form)
  73.   "Like prin1-to-string except: if the string contains embedded nulls (unlikely
  74. but possible) then replace each one with \"\\000\"."
  75.   (let ((string (prin1-to-string form)))
  76.     (let ((parts '())
  77.       index)
  78.       (while (setq index (string-match "\0" string))
  79.     (setq parts 
  80.           (apply 'list "\\000" (substring string 0 index) parts))
  81.     (setq string (substring string (1+ index))))
  82.       (if (not parts)
  83.       string
  84.     (setq parts (apply 'list string parts))
  85.     (apply 'concat (nreverse parts))))))
  86.  
  87. ;; Backwards compatibility
  88. (fset 'tooltalk::prin1-to-string-carefully 'tooltalk:prin1-to-string)
  89.  
  90.  
  91. (defun tooltalk:read-from-string (str)
  92.   "Like read-from-string except: an error is signalled if the entire 
  93. string can't be parsed."
  94.   (let ((res (read-from-string str)))
  95.     (if (< (cdr res) (length str))
  96.     (error "Parse of input string ended prematurely."
  97.            str))
  98.     (car res)))
  99.  
  100.  
  101. (defun tooltalk::eval-string (str)
  102.   (let ((result (eval (car (read-from-string str)))))
  103.     (tooltalk:prin1-to-string result)))
  104.  
  105.  
  106. (defun tooltalk-eval-handler (msg pat)
  107.   (let ((str (get-tooltalk-message-attribute msg 'arg_val 0))
  108.     (result-str nil)
  109.     (failp t))
  110.     (unwind-protect
  111.     (cond
  112.      ;; Assume That the emacs debugger will handle errors.
  113.      ;; If the user throws from the debugger to the cleanup
  114.      ;; form below, failp will remain t.
  115.      (debug-on-error   
  116.       (setq result-str (tooltalk::eval-string str)
  117.         failp nil))
  118.  
  119.      ;; If an error occurs as a result of evaluating
  120.      ;; the string or printing the result, then we'll return 
  121.      ;; a string version of error-info.
  122.      (t
  123.       (condition-case error-info
  124.           (setq result-str (tooltalk::eval-string str)
  125.             failp nil)
  126.         (error 
  127.          (let ((error-str (tooltalk:prin1-to-string error-info)))
  128.            (setq result-str error-str
  129.              failp t))))))
  130.  
  131.       ;; If we get to this point and result-str is still nil, the
  132.       ;; user must have thrown out of the debuggger
  133.       (let ((reply-type (if failp 'fail 'reply))
  134.         (reply-value (or result-str "(debugger exit)")))
  135.     (set-tooltalk-message-attribute reply-value msg 'arg_val 0)
  136.     (return-tooltalk-message msg reply-type)))))
  137.  
  138.  
  139. (defun tooltalk-make-client-frame-handler (m p)
  140.   (let ((nargs (get-tooltalk-message-attribute m 'args_count)))
  141.     (if (not (= 3 nargs))
  142.     (progn
  143.       (set-tooltalk-message-attribute "wrong number of arguments" m 'status_string)
  144.       (return-tooltalk-message m 'fail))))
  145.  
  146.   ;; Note: relying on the fact that arg_ival is returned as a string
  147.  
  148.   (let* ((name   (get-tooltalk-message-attribute m 'arg_val 0))
  149.      (window (get-tooltalk-message-attribute m 'arg_ival 1))
  150.      (args (list (cons 'name name) (cons 'window-id window)))
  151.      (frame (make-frame args)))
  152.     (set-tooltalk-message-attribute (frame-name frame) m 'arg_val 2)
  153.     (return-tooltalk-message m 'reply)))
  154.  
  155.  
  156.  
  157. (defun tooltalk-load-file-handler (m p)
  158.   (let ((path (get-tooltalk-message-attribute m 'file)))
  159.     (condition-case error-info 
  160.     (progn
  161.       (load-file path)
  162.       (return-tooltalk-message m 'reply))
  163.       (error 
  164.        (let ((error-string (tooltalk:prin1-to-string error-info)))
  165.     (set-tooltalk-message-attribute error-string m 'status_string)
  166.     (return-tooltalk-message m 'fail))))))
  167.  
  168.  
  169. (defun tooltalk-status-handler (m p)
  170.   (return-tooltalk-message m 'reply))
  171.  
  172.  
  173. ;; Hack the command-line.
  174.  
  175. (defun command-line-do-tooltalk (arg)
  176.   "Connect to the ToolTalk server."
  177. ;  (setq command-line-args-left
  178. ;    (cdr (tooltalk-open-connection (cons (car command-line-args)
  179. ;                         command-line-args-left))))
  180.   (if (tooltalk-open-connection)
  181.       (register-initial-tooltalk-patterns)
  182.     (beep)
  183.     (message "Warning: unable to connect to a ToolTalk server.")))
  184.  
  185. (setq command-switch-alist
  186.       (append command-switch-alist
  187.           '(("-tooltalk" . command-line-do-tooltalk))))
  188.  
  189. ;; Add some selection converters.
  190.  
  191. (defun xselect-convert-to-ttprocid (selection type value)
  192.   (let* ((msg (create-tooltalk-message))
  193.      (ttprocid (get-tooltalk-message-attribute msg 'sender)))
  194.     (destroy-tooltalk-message msg)
  195.     ttprocid
  196.     ))
  197.  
  198. (defun xselect-convert-to-ttsession (selection type value)
  199.   (let* ((msg (create-tooltalk-message))
  200.      (ttsession (get-tooltalk-message-attribute msg 'session)))
  201.     (destroy-tooltalk-message msg)
  202.     ttsession
  203.     ))
  204.  
  205. (if (boundp 'selection-converter-alist)
  206.     (setq selection-converter-alist
  207.       (append
  208.        selection-converter-alist
  209.        '((SPRO_PROCID . xselect-convert-to-ttprocid)
  210.          (SPRO_SESSION . xselect-convert-to-ttsession)
  211.          )))
  212.   (setq selection-converter-alist
  213.     '((SPRO_PROCID . xselect-convert-to-ttprocid)
  214.       (SPRO_SESSION . xselect-convert-to-ttsession))))
  215.   
  216.